home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / riscas.t < prev    next >
Encoding:
Text File  |  1989-10-27  |  5.9 KB  |  219 lines
  1. (herald as)
  2.  
  3. ;;; $4 -> (lit . 4)
  4. ;;; 3(r4) -> (4 . 3)
  5. ;;; label -> label
  6. ;;; (r4,r5) -> ((4 . 5))
  7.  
  8. (define-constant jump-op/jabs 0)
  9. (define-constant jump-op/jn=  1) (define-constant jump-op/j=   -1)
  10. (define-constant jump-op/j>   2) (define-constant jump-op/j<=  -2)
  11. (define-constant jump-op/j>=  3) (define-constant jump-op/j<   -3)
  12. (define-constant jump-op/uj>  4) (define-constant jump-op/uj<= -4) 
  13. (define-constant jump-op/uj>= 5) (define-constant jump-op/uj<  -5)
  14. (define-constant jump-op/not_negative 6) (define-constant jump-op/negative -6)
  15. (define-constant jump-op/no_overflow  7) (define-constant jump-op/overflow -7) 
  16. (define-constant jump-op/jl 8)                                                                   
  17.  
  18. (define (reverse-jump-ops j)
  19.   (select j
  20.     ((jump-op/j<) jump-op/j>)
  21.     ((jump-op/j>) jump-op/j<)
  22.     ((jump-op/j<=) jump-op/j>=)
  23.     ((jump-op/j>=) jump-op/j<=)
  24.     ((jump-op/uj<) jump-op/uj>)
  25.     ((jump-op/uj>) jump-op/uj<)
  26.     ((jump-op/uj<=) jump-op/uj>=)
  27.     ((jump-op/uj>=) jump-op/uj<=)
  28.     (else j)))
  29.  
  30. (define-operation (read-registers . args) (ignore args) (return zero zero))
  31. (define-operation (write-register . args) (ignore args) zero)
  32.  
  33. (define-structure-type ib
  34.   address
  35.   node
  36.   instructions
  37.   1next
  38.   0next
  39.   cc
  40.   avoid-jump?
  41.   previous
  42. (((pretty-print self port)
  43.   (pretty-print (ib-instructions self) port))))
  44.  
  45. (let ((m (stype-master ib-stype)))
  46.   (set (ib-instructions m) nil)
  47.   (set (ib-1next m) nil)
  48.   (set (ib-0next m) nil)
  49.   (set (ib-avoid-jump? m) nil)
  50.   (set (ib-previous m) nil)
  51.   (set (ib-cc m) nil)
  52.   (set (ib-address m) nil))
  53.  
  54. (lset *current-ib* nil)
  55. (lset *cal* nil)
  56. (lset *bits* nil)
  57. (lset *is* nil)
  58. (lset *template-ibs* nil)
  59. (lset *useless-ibs* nil)
  60. (lset *current-comment* nil)
  61. (lset *assembly-comments?* t)
  62.  
  63. (define (assemble-init c)
  64.   (set *cal* (make-table 'assembly-labels))
  65.   (set *template-ibs* nil)
  66.   (set *current-ib* (make-ib))
  67.   (set (ib-node *current-ib*) nil)
  68.   (set *useless-ibs* nil)
  69.   (set *current-comment* nil)
  70.   (c))
  71.  
  72. (define (code-vector-offset thing)
  73.   (fx+ (ib-address (table-entry *cal* thing)) *offset-from-template*))
  74.  
  75. (define (assemble)
  76.   (modify (ib-instructions *current-ib*) reverse!)
  77.   (push *template-ibs* *current-ib*)
  78.   (remove-useless-blocks)
  79.   (iterate loop ((ibs (reverse! *template-ibs*)) (i 0) (is '()))
  80.     (cond ((null? ibs)
  81.        (assemble-bits i (reverse! is)))
  82.       (else
  83.        (add-to-front (car ibs))
  84.        (receive (i is) (linearize-code-blocks i is)
  85.          (loop (cdr ibs) i is))))))
  86.  
  87.      
  88. (define-operation (instruction-as-string . args) "")
  89.  
  90.  
  91. (define (listing) (assembly-list *is* *bits*))
  92.  
  93. (define quicklist listing)
  94.  
  95. (define (cons-an-ib thing)
  96.   (let ((ib (make-ib)))
  97.     (set (table-entry *cal* thing) ib)
  98.     (set (ib-node ib) thing)
  99.     ib))
  100.  
  101. (define (maybe-cons-an-ib thing)
  102.   (or (table-entry *cal* thing)
  103.       (cons-an-ib thing)))
  104.  
  105.  
  106. (define (emit-comment string . args)
  107.   (set *current-comment* (cons string args)))
  108.  
  109. (define (emit-template l h)
  110.   (emit-tag l)
  111.   (cond ((neq? l h)
  112.      (let ((h (maybe-cons-an-ib h)))
  113.        (push *template-ibs* h)
  114.        (push (ib-instructions *current-ib*) `(,template1 () ,l ,h))))
  115.     (else
  116.      (push (ib-instructions *current-ib*) `(,template1 () ,l ,nil))))
  117.   (push (ib-instructions *current-ib*) `(,template2 ()))
  118.   (push (ib-instructions *current-ib*) `(,template3 ,*current-comment* ,l))
  119.   (set *current-comment* nil))
  120.  
  121. (define (emit-bogus-stack-template)
  122.   (emit-stack-template nil))
  123.  
  124. (define (emit-stack-template l)
  125.   (push (ib-instructions *current-ib*) `(,stemplate1 () ,l))
  126.   (push (ib-instructions *current-ib*) `(,template2 ()))
  127.   (push (ib-instructions *current-ib*)
  128.     `(,stemplate3 ,*current-comment* ,l ,*lambda*))
  129.   (set *current-comment* nil))
  130.  
  131. (define (emit-tag l)
  132.   (if (and (null? (ib-instructions *current-ib*))
  133.        (let ((node (ib-node *current-ib*)))
  134.          (or (not (node? node))
  135.          (not (lambda-node? node))
  136.          (neq? (lambda-strategy node) strategy/open)))
  137.        (not (ib-0next *current-ib*)))
  138.       (push *useless-ibs* *current-ib*)
  139.       (push *template-ibs* *current-ib*))
  140.   (modify (ib-instructions *current-ib*) reverse!)
  141.   (set *current-ib* (maybe-cons-an-ib l)))
  142.  
  143. (define (address-of x)
  144.   (xcond ((ib? x) (ib-address x))
  145.          ((symbol? x) (table-entry *cal* x))))
  146.  
  147. (define (label l) (cons (if (eq? (lambda-strategy l) strategy/heap)
  148.                 'template
  149.                 'label)
  150.             (maybe-cons-an-ib l)))
  151.  
  152. (define (asemit op args)
  153.   (push (ib-instructions *current-ib*) (cons op (cons *current-comment* args)))
  154.   (set *current-comment* nil))
  155.  
  156. (define (tp-offset thing)
  157.   `(tp-offset . ,(maybe-cons-an-ib thing)))
  158.  
  159. (define (label-offset thing)
  160.   `(label-offset . ,(maybe-cons-an-ib thing)))
  161.  
  162. (define (handler-diff method obj)
  163.   `(handler-diff . (,(maybe-cons-an-ib method) . ,(maybe-cons-an-ib obj))))
  164.  
  165. (define (remove-useless-blocks)
  166.   (walk remove-useless-block *useless-ibs*))
  167.   
  168.  
  169. (define (remove-useless-block ib)
  170.   (let ((next (ib-1next ib)))
  171.     (walk (lambda (p)
  172.         (push (ib-previous next) p)
  173.         (if (eq? (ib-1next p) ib)
  174.         (set (ib-1next p) next)
  175.         (set (ib-0next p) next)))
  176.       (ib-previous ib))))
  177.       
  178. (lset *blocks-pending* '())
  179.  
  180.  
  181.  
  182.  
  183.  
  184. (define (lapemit op . args)
  185.   (asemit op args))
  186.  
  187. (define (lap-transduce is)
  188.   (walk (lambda (inst)
  189.       (cond ((atom? inst)
  190.          (or (ib-cc *current-ib*) (emit-jump inst))
  191.          (emit-tag inst))
  192.         ((table-entry lap-pseudo-ops (car inst))
  193.          => (lambda (proc) (apply proc (cdr inst))))
  194.         ((table-entry lap-instructions (car inst))
  195.          => (lambda (proc)
  196.               (apply emit proc (map! lap-eval (cdr inst)))))
  197.         (else (error "Bad lap ~s" inst))))
  198.     is))
  199.  
  200. (define (lap-eval x)
  201.   (cond ((atom? x)
  202.      (*value orbit-env x))
  203.     (else
  204.      (case (car x)
  205.        (($)
  206.         (cons 'lit (eval (cadr x) orbit-env)))
  207.        ((d@r)
  208.         (list 'reg-offset (lap-eval (cadr x))
  209.           (let ((x (caddr x)))
  210.             (cond ((and (pair? x) (eq? (car x) 'static))
  211.                (static (cadr x)))
  212.               (else (eval x orbit-env))))))
  213.        ((d@nil) (list 'reg-offset nil-reg (eval (cadr x) orbit-env)))
  214.        (else (error "Bad lap operand ~s" x))))))
  215.  
  216. (define lap-table (make-table 'lap-table))
  217. (define (define-lap x y)
  218.   (set (table-entry lap-table x) y))
  219.